hometask2

Задание 1

Загрузим датасет:

insur <- read.csv("insurance_cost.csv")
head(insur)

##   age    sex    bmi children smoker    region   charges
## 1  19 female 27.900        0    yes southwest 16884.924
## 2  18   male 33.770        1     no southeast  1725.552
## 3  28   male 33.000        3     no southeast  4449.462
## 4  33   male 22.705        0     no northwest 21984.471
## 5  32   male 28.880        0     no northwest  3866.855
## 6  31 female 25.740        0     no southeast  3756.622

Это данные по базовым показателям здоровья индивида и сумме, которую страховая компания заплатила за его лечение в год.

Вспомним немного описание данных:

skimr::skim(insur)

Data summary

Name	insur
Number of rows	1338
Number of columns	7
_______________________
Column type frequency:
character	3
numeric	4
________________________
Group variables	None

Variable type: character

skim_variable	n_missing	complete_rate	min	max	empty	n_unique	whitespace
sex	0	1	4	6	0	2	0
smoker	0	1	2	3	0	2	0
region	0	1	9	9	0	4	0

Variable type: numeric

skim_variable	n_missing	complete_rate	mean	sd	p0	p25	p50	p75	p100	hist
age	0	1	39.21	14.05	18.00	27.00	39.00	51.00	64.00	▇▅▅▆▆
bmi	0	1	30.66	6.10	15.96	26.30	30.40	34.69	53.13	▂▇▇▂▁
children	0	1	1.09	1.21	0.00	0.00	1.00	2.00	5.00	▇▂▂▁▁
charges	0	1	13270.42	12110.01	1121.87	4740.29	9382.03	16639.91	63770.43	▇▂▁▁▁

Нулевых значений в возрасте, ИМТ и выплатах нет. Чистить не нужно.

Задание 2

Сделаем интерактивный график отношения ИМТ и затрат на страховку:

plot_ly(data = insur,
  x = ~ bmi,
  y = ~ charges,
  type = "scatter",
  mode = 'markers',#без этой строки у меня не работает интерактив
  color = ~ smoker,
  colors = "Set2"#и без указания палетки тоже не сработало бы
)

Задание 3

То же через ggplotly:

plot <- insur %>%
  ggplot(aes(x=bmi, y=charges, color = smoker)) + 
  geom_point() +
  theme_dark()
ggplotly(plot)

Задание 4

Корреляционный анализ

Как было на занятии

Сначала матрицу строим:

insur_num <- insur %>%
  select(is.integer | is.numeric)
#head(insur_num)

insur_cor <- cor(insur_num)
insur_cor

##                age   children       bmi    charges
## age      1.0000000 0.04246900 0.1092719 0.29900819
## children 0.0424690 1.00000000 0.0127589 0.06799823
## bmi      0.1092719 0.01275890 1.0000000 0.19834097
## charges  0.2990082 0.06799823 0.1983410 1.00000000

И нарисуем:

corrplot(insur_cor, method = 'number')

Новый тип графика 1

из пакета corpplot:

corrplot(insur_cor,
         order = "alphabet",
         cl.pos = 'b',
         tl.pos = 'd',
         col = COL1('Blues'),
         diag = FALSE)

Для себя описание параметров: order = “AOE” - порядок, в котором выводят названия переменных (в алфавитном)

cl.pos = ‘b’ - определяет положение цветной шкалы (сейчас снизу).

tl.pos = ‘d’ - определяет положение текстовых надписей переменных (по диагонали)

col = COL1(‘Blues’) - настройка палитры графика:

COL1() - для визуализации неотрицательной или неположительной матрицы.

COL2() - для визуализации матрицы, элементы которой частично положительные, а частично отрицательные.

Цветовые палитры у них отличаются и не работают, если указана неверная.

diag = FALSE - нужно ли обозначать корреляцию на ячейках по диагонали, в данном случае работает и без этого т.к. там у нас текст, но в ином случае можно выбрать показывать или нет.

Для себя оставлю ссылку

Новый тип графика 2

из пакета corrr:

insur_cor%>%
  rplot(print_cor = TRUE, colors = c("cyan", "blue"), legend = TRUE)

Выглядит плохо, но хотелось посмотреть corrr.

Задание 5

Создадим новый датафрейм (номинативные в дамми/бинарные):

library('fastDummies')    
insur_wD <- dummy_cols(insur, select_columns = c('sex', 'smoker', 'region')) 
#хотя можно и через mutate с case_when

insur_wD <- insur_wD %>%
  select(is.numeric)

head(insur_wD)

##   age    bmi children   charges sex_female sex_male smoker_no smoker_yes
## 1  19 27.900        0 16884.924          1        0         0          1
## 2  18 33.770        1  1725.552          0        1         1          0
## 3  28 33.000        3  4449.462          0        1         1          0
## 4  33 22.705        0 21984.471          0        1         1          0
## 5  32 28.880        0  3866.855          0        1         1          0
## 6  31 25.740        0  3756.622          1        0         1          0
##   region_northeast region_northwest region_southeast region_southwest
## 1                0                0                0                1
## 2                0                0                1                0
## 3                0                0                1                0
## 4                0                1                0                0
## 5                0                1                0                0
## 6                0                0                1                0

Задание 6

Иерархическая кластеризация

Отшкалируем данные:

insur_sc <- scale(insur_wD)
head(insur_sc)

##             age        bmi    children    charges sex_female   sex_male
## [1,] -1.4382265 -0.4531506 -0.90827406  0.2984722  1.0101410 -1.0101410
## [2,] -1.5094011  0.5094306 -0.07873775 -0.9533327 -0.9892209  0.9892209
## [3,] -0.7976553  0.3831636  1.58033487 -0.7284023 -0.9892209  0.9892209
## [4,] -0.4417824 -1.3050431 -0.90827406  0.7195739 -0.9892209  0.9892209
## [5,] -0.5129570 -0.2924471 -0.90827406 -0.7765118 -0.9892209  0.9892209
## [6,] -0.5841316 -0.8073542 -0.90827406 -0.7856145  1.0101410 -1.0101410
##       smoker_no smoker_yes region_northeast region_northwest region_southeast
## [1,] -1.9698501  1.9698501       -0.5650556       -0.5662062       -0.6110952
## [2,]  0.5072734 -0.5072734       -0.5650556       -0.5662062        1.6351833
## [3,]  0.5072734 -0.5072734       -0.5650556       -0.5662062        1.6351833
## [4,]  0.5072734 -0.5072734       -0.5650556        1.7648211       -0.6110952
## [5,]  0.5072734 -0.5072734       -0.5650556        1.7648211       -0.6110952
## [6,]  0.5072734 -0.5072734       -0.5650556       -0.5662062        1.6351833
##      region_southwest
## [1,]        1.7648211
## [2,]       -0.5662062
## [3,]       -0.5662062
## [4,]       -0.5662062
## [5,]       -0.5662062
## [6,]       -0.5662062

Сначала создади матрицу дистанций:

Расчёт дендрограммы кластеров:

insur_hc <- hclust(d = insur_dist,
                   method = "ward.D2")

Визуализация:

fviz_dend(insur_hc,
          cex = 0.1)

Доп. визуализация матрицы дистанций:

fviz_dist(insur_dist, gradient = list(low = "blue", mid = "white", high = "red"))

#Задание 7

Раскраска кластеров:

insur_sc <- scale(insur_wD)

# Разбиваем на 5 групп дерево
grp <- cutree(insur_hc, k = 5)
head(grp, n = 5)#вектор с номерами кластера

## [1] 1 2 2 3 3

# сколько в каждой группе
table(grp)

## grp
##   1   2   3   4   5 
## 274 273 267 257 267

df<-as.data.frame(insur_sc)

# добавим группы 
df$grp <- grp

Просто покрашена:

fviz_dend(insur_hc, k = 5, # Cut in four groups
cex = 0.5, # label size
k_colors = c("#2E9FDF", "#00CC33", "#E7B800", "#FC4E07", "#660099"),
color_labels_by_k = TRUE # color labels by groups
)

## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.

Покрашена + границы

fviz_dend(insur_hc, k = 5, # Cut in four groups
cex = 0.5, # label size
k_colors = c("#2E9FDF", "#00CC33", "#E7B800", "#FC4E07", "#660099"),
color_labels_by_k = TRUE, # color labels by groups
rect = TRUE, # Add rectangle around groups
rect_border = "black"
)

## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.

Покрашена и закрашена:

fviz_dend(insur_hc,  k = 5,
  rect = TRUE,
  rect_fill = TRUE,
  rect_border = "jco",
  k_colors = "jco",
  cex = 0.1
)

phylogenic-like tree:

fviz_dend(insur_hc, k = 5, k_colors = "jco", type = "phylogenic", relep = TRUE , phylo_layout = "layout_as_tree")

Scatter plot:

fviz_cluster(list(data = df, cluster = grp)
            )

(видимо из-за переменных даммис кластеры разбиваются, когда строила без них для каждого кластера было одно облачко)

#Задание 8

Одновременно heat map и tree map:

pheatmap(insur_sc, cutree_rows = 6)#с разбиением на подгруппы

Можно заметить, что бОльшие значения charges соответствует курящим (оранжевые прямоугольники по charges и оранжевые по smoker_yes)

library("d3heatmap")

d3heatmap(insur_sc, colors = "RdYlBu",
          k_row = 6, # Number of groups in rows
          k_col = 2 # Number of groups in columns
          )

Должно было быть красиво, но видимо из-за объёма данных не закрасились прямоугольнички, но интерактив работает. Исходный пример:

d3heatmap(scale(mtcars), colors = "RdYlBu",
          k_row = 6, # Number of groups in rows
          k_col = 2 # Number of groups in columns
          )

#Задание 9

Проведём анализ PCA

insur.pca <- prcomp(insur_wD, scale = T)
insur.pca$rotation#веса главных компонент

##                           PC1          PC2          PC3           PC4
## age               0.074783666 -0.058852219  0.105524125  0.1014109474
## bmi               0.093561955  0.038801873  0.521403475  0.0303771541
## children          0.027785271  0.011309807 -0.013233447  0.1238890238
## charges           0.533651705 -0.130821961  0.005749107  0.0484819280
## sex_female       -0.152794587 -0.687701110  0.043685850  0.0007434309
## sex_male          0.152794587  0.687701110 -0.043685850 -0.0007434309
## smoker_no        -0.564890399  0.124959968  0.118482771 -0.0174463686
## smoker_yes        0.564890399 -0.124959968 -0.118482771  0.0174463686
## region_northeast -0.006005881 -0.016701389 -0.363891193 -0.4220767696
## region_northwest -0.053941542 -0.009346488 -0.320389371 -0.1046530598
## region_southeast  0.101144455  0.012583875  0.670590572 -0.2956203900
## region_southwest -0.045019353  0.012971745 -0.011991395  0.8330616582
##                           PC5         PC6         PC7          PC8         PC9
## age              -0.004177559 -0.78397855  0.31617636 -0.416750321  0.28501957
## bmi               0.007919532 -0.24450746  0.08742266  0.789045636  0.16393250
## children         -0.087753149 -0.33721190 -0.92752433 -0.009471695  0.04210556
## charges          -0.012177926 -0.21486417  0.06329618  0.030802089 -0.80277508
## sex_female        0.002544583  0.02006494 -0.02110925  0.030541334  0.00495393
## sex_male         -0.002544583 -0.02006494  0.02110925 -0.030541334 -0.00495393
## smoker_no         0.012646442 -0.16745420  0.02438755  0.001106765 -0.34949175
## smoker_yes       -0.012646442  0.16745420 -0.02438755 -0.001106765  0.34949175
## region_northeast  0.603158292 -0.21025889 -0.03307944  0.186068805  0.02229031
## region_northwest -0.763269598 -0.10936580  0.09955064  0.182689049  0.01275974
## region_southeast -0.045577126  0.20086158 -0.11194087 -0.364324587 -0.02373964
## region_southwest  0.208039464  0.11096476  0.04965841  0.009506976 -0.01039141
##                           PC10          PC11          PC12
## age               1.306025e-16 -1.951155e-16 -4.133818e-16
## bmi               2.016792e-16  1.319054e-16 -2.353279e-16
## children         -1.697237e-16 -1.707754e-16  3.572821e-17
## charges          -2.529172e-16  3.175752e-16  1.350921e-15
## sex_female       -7.051097e-01 -5.292035e-02  4.439052e-03
## sex_male         -7.051097e-01 -5.292035e-02  4.439052e-03
## smoker_no         2.375034e-03  2.762286e-02  7.065630e-01
## smoker_yes        2.375034e-03  2.762286e-02  7.065630e-01
## region_northeast -3.712941e-02  4.931050e-01 -1.915298e-02
## region_northwest -3.716832e-02  4.936218e-01 -1.917305e-02
## region_southeast -3.857063e-02  5.122454e-01 -1.989642e-02
## region_southwest -3.716832e-02  4.936218e-01 -1.917305e-02

summary(insur.pca)

## Importance of components:
##                           PC1    PC2    PC3    PC4    PC5     PC6     PC7
## Standard deviation     1.6737 1.4023 1.2417 1.1513 1.1498 1.07055 0.98583
## Proportion of Variance 0.2334 0.1639 0.1285 0.1105 0.1102 0.09551 0.08099
## Cumulative Proportion  0.2334 0.3973 0.5258 0.6363 0.7465 0.84196 0.92295
##                            PC8     PC9      PC10      PC11      PC12
## Standard deviation     0.87032 0.40877 2.012e-15 1.043e-15 7.413e-16
## Proportion of Variance 0.06312 0.01392 0.000e+00 0.000e+00 0.000e+00
## Cumulative Proportion  0.98608 1.00000 1.000e+00 1.000e+00 1.000e+00

fviz_eig(insur.pca, 
         addlabels = T, 
         ylim = c(0, 40))

60% (объясняем 2/3 данных) достигается на PC4. 90% - на PC7.Не очень хорошо.

Резко падает прирост % на 9-10 компонентах (было 6,3%, а упало до 1,4%) и если бы надо было уменьшать размерность (количество переменных), то выкинула бы их.

Анализ компонент (как каждая переменная влияет на главные компоненты):

fviz_pca_var(insur.pca, col.var = "contrib")

очевидно, что пол Ж/М отрицательно скоррелированы, аналогично (не)курящие.

На первую компоненту (Dim1) влияют (не)курящие и выплаты (по этой оси идёт бОльшая вариация этих признаков). На вторую компоненту (Dim2) - пол. Что касается остальных переменных, то они вносят малый вклад в первые две компоненты. А выплаты скореллированы с курящими. Т.е. в целом сильно выражен эффект от пола и курения.

Посмотрим на топ 5 самых важных переменных с т.з. их вариации в PC1 и PC2:

fviz_pca_var(insur.pca, 
             select.var = list(contrib = 5),
             col.var = "contrib")

Итого важны пол, отношение к курению, выплаты.

Посмотрим из чего состоят 1, 2 и 3 главные компоненты:

fviz_contrib(insur.pca, choice = "var", axes = 1) # 1

fviz_contrib(insur.pca, choice = "var", axes = 2) # 2

fviz_contrib(insur.pca, choice = "var", axes = 3) # 3

Как и на диаграмме выше видим, что для самой первой компоненты (PC1) бОльший вклад приходит от курящих (по факту бинарные данные, которые, как мы обсуждали на лекции, сильно влияют на анализ), на вторую компоненту пол, а на третью уже регион, ИМТ.

Сделаем biplot. Посмотрим, наблюдается ли разница между группами по age:

library(ggbiplot)
# Сделаем корректные данные для группировки по age
insur_w_ch <- insur_wD %>% 
  mutate(
    age_group = case_when(
      age <20 ~ "до 20",
      age >19 & age < 36 ~ "20-35",
      age > 35 & age < 51 ~ "36-50",
      age > 50 ~ "после 50"
    ))

# Визуализируем с группировкой по возрастным группам (для этого переменную нужно сделать фактором)
ggbiplot(insur.pca, 
         scale=0, 
         groups = as.factor(insur_w_ch$age_group), 
         ellipse = T,
         alpha = 0.2) +
  theme_minimal()

Не очень кластеризуются по возрастным группам (до чего, наверно, можно было догадаться по тому, что вектор age невелик), но, если правильно понимаю график, то у мы видим 4 какие-то кластера, которые, по-видимому, кластеризуются на основании какого-то другого параметра.

Сделаю доп кластеризацию, по другому параметру, просто чтобы проверить эти 4 облака точек.Судя по их расположению, можно предположить, что стоит поиграть с полом и курением:

# Сделаем корректные данные для группировки по age и smoker
insur_w_ch <- insur_wD %>% 
  mutate(
    clust_m_s = case_when(
      (sex_male == 1) & (smoker_yes == 1) ~ "1-1",
      (sex_male == 1) & (smoker_yes == 0) ~ "1-0",
      (sex_male == 0) & (smoker_yes == 1) ~ "0-1",
      (sex_male == 0) & (smoker_yes == 0) ~ "0-0"
    ))

#сделаем так, что комбинации пола и курения такие: М-курит = 1-1, М-не_курит = 1-0, Ж-курит = 0-1, Ж-не_курит = 0-0

# Визуализируем с такой группировкой
ggbiplot(insur.pca, 
         scale=0, 
         groups = as.factor(insur_w_ch$clust_m_s), 
         ellipse = T,
         alpha = 0.2) +
  theme_minimal()

Кластеры выделились согласно облачкам.

#Задание 11 Видимо, это как раз про то, чего я пыталась добиться выше. Но посмотрю ещё дополнительно

Отдельно по полу:

insur_w_ch <- insur_wD %>% 
  mutate(
    sex = case_when(
      sex_male == 1 ~ "male",
      sex_male == 0 ~ "female"
    ))
# по факту просто вернулись к исходной переменной пол
ggbiplot(insur.pca, 
         scale=0, 
         groups = as.factor(insur_w_ch$sex), 
         ellipse = T,
         alpha = 0.2) +
  theme_minimal()

Разбилось (как раз вдоль направления пола)

Отдельно по курению:

insur_w_ch <- insur_wD %>% 
  mutate(
    smoker = case_when(
      smoker_yes == 1 ~ "male",
      smoker_yes == 0 ~ "female"
    ))
# по факту просто вернулись к исходной переменной smoker
ggbiplot(insur.pca, 
         scale=0, 
         groups = as.factor(insur_w_ch$smoker), 
         ellipse = T,
         alpha = 0.2) +
  theme_minimal()

Разбилось по другому направлению.

Отдельно по выплатам:

insur_w_ch <- insur_wD %>% 
  mutate(
    charg_group = case_when(
      charges <=5000 ~ "<= 5K",
      charges >5000 & charges <= 15000 ~ "5K-15K",
      charges > 15000 & charges < 50000 ~ "15K-50K",
      charges > 50000 ~ "после 50"
    ))
# по факту просто вернулись к исходной переменной smoker
ggbiplot(insur.pca, 
         scale=0, 
         groups = as.factor(insur_w_ch$charg_group), 
         ellipse = T,
         alpha = 0.2) +
  theme_minimal()

Можно было бы взять и 2 градации для выплат, как раз было бы до 0 и после.

#Задание 12

Наверно стоит для начала взглянуть по каким переменным самый большой разброс (закоменченные library(psych) и describe. Там по sd идёт charges, age, bmi, children… Попробую удалить те, что с не самым большим разбросом (как раз пол, регион, курение, хотя наверно я много удаляю)

#смотрю разброс данных
#library(psych)
#describe(insur_wD)

insur_v_1 <- insur_wD %>%
  select( 'age', 'bmi', 'children', 'charges')

#PCA
insur.pca_1 <- prcomp(insur_v_1, scale = T)
summary(insur.pca_1)

## Importance of components:
##                          PC1    PC2    PC3    PC4
## Standard deviation     1.195 0.9962 0.9468 0.8264
## Proportion of Variance 0.357 0.2481 0.2241 0.1707
## Cumulative Proportion  0.357 0.6051 0.8293 1.0000

#Приходим к тому, что у нас на 2 компоненте достигается 60%, он наверно потому что мы много удалили

fviz_eig(insur.pca_1, 
         addlabels = T, 
         ylim = c(0, 40))

fviz_contrib(insur.pca_1, choice = "var", axes = 1) # 1

fviz_contrib(insur.pca_1, choice = "var", axes = 2) # 2

fviz_contrib(insur.pca_1, choice = "var", axes = 3) # 3

ggbiplot(insur.pca_1, 
         scale=0) +
  theme_minimal()

Много удалилось данных, поэтому наверно пример не очень.

Если не будем ничего удалять, а заменим возраст на даммис

insur_v_2 <- insur_wD %>% 
  mutate(
    age_group = case_when(
      age <20 ~ "до 20",
      age >19 & age < 36 ~ "20-35",
      age > 35 & age < 51 ~ "36-50",
      age > 50 ~ "после 50"
    ))

#и делаем их дамми
insur_v_2 <- dummy_cols(insur_v_2, select_columns = "age_group") 
insur_v_2$age <- NULL
insur_v_2$age_group <- NULL

#PCA
insur.pca_2 <- prcomp(insur_v_2, scale = T)
summary(insur.pca_2)

## Importance of components:
##                           PC1    PC2    PC3    PC4     PC5     PC6     PC7
## Standard deviation     1.6753 1.4037 1.2577 1.2318 1.20723 1.15450 1.14923
## Proportion of Variance 0.1871 0.1313 0.1055 0.1012 0.09716 0.08886 0.08805
## Cumulative Proportion  0.1871 0.3185 0.4239 0.5251 0.62224 0.71110 0.79915
##                            PC8     PC9   PC10    PC11      PC12     PC13
## Standard deviation     1.11835 0.90338 0.8789 0.41658 1.097e-15 7.85e-16
## Proportion of Variance 0.08338 0.05441 0.0515 0.01157 0.000e+00 0.00e+00
## Cumulative Proportion  0.88253 0.93693 0.9884 1.00000 1.000e+00 1.00e+00
##                             PC14      PC15
## Standard deviation     6.591e-16 2.725e-16
## Proportion of Variance 0.000e+00 0.000e+00
## Cumulative Proportion  1.000e+00 1.000e+00

fviz_eig(insur.pca_2, 
         addlabels = T, 
         ylim = c(0, 40))

fviz_contrib(insur.pca_2, choice = "var", axes = 1) # 1

fviz_contrib(insur.pca_2, choice = "var", axes = 2) # 2

fviz_contrib(insur.pca_2, choice = "var", axes = 3) # 3

ggbiplot(insur.pca_2, 
         scale=0) +
  theme_minimal()

Не сильно качество изменило, но наверно потому что изначально возраст не сильно влиял на компоненты.

Изначально у нас даммиес-переменные сильно влияют на PCA, попробуем с ними что-то сделать. Просто сделаем бинарными smoker (yes=1, no=0) и sex (male=1, female=0)

insur_v_3 <- insur %>%
  mutate(
    smoker = if_else(smoker == 'yes', 1, 0),
    sex = if_else(sex == 'female', 1, 0),
    )

#и делаем их дамми
insur_v_3 <- dummy_cols(insur_v_3, select_columns = "region" )
insur_v_3$region <- NULL

#PCA
insur.pca_3 <- prcomp(insur_v_3, scale = T)
summary(insur.pca_3)

## Importance of components:
##                           PC1    PC2    PC3    PC4    PC5    PC6    PC7     PC8
## Standard deviation     1.3939 1.2182 1.1510 1.1496 1.0403 1.0018 0.9767 0.86822
## Proportion of Variance 0.1943 0.1484 0.1325 0.1321 0.1082 0.1004 0.0954 0.07538
## Cumulative Proportion  0.1943 0.3427 0.4752 0.6073 0.7156 0.8159 0.9113 0.98669
##                            PC9      PC10
## Standard deviation     0.36478 9.986e-16
## Proportion of Variance 0.01331 0.000e+00
## Cumulative Proportion  1.00000 1.000e+00

#Приходим к тому, что у нас на 2 компоненте достигается 60%, он наверно потому что мы много удалили

fviz_eig(insur.pca_3, 
         addlabels = T, 
         ylim = c(0, 40))

fviz_contrib(insur.pca_3, choice = "var", axes = 1) # 1

fviz_contrib(insur.pca_3, choice = "var", axes = 2) # 2

fviz_contrib(insur.pca_3, choice = "var", axes = 3) # 3

ggbiplot(insur.pca_3, 
         scale=0) +
  theme_minimal()

Качество не улучшилось, а похоже стало даже хуже. Хотя мы ничего не изменили сильно, кроме как теперь не отдельные колонки для курящих и некурящих, а в одной колонке 1 и 0.

В Dim1 третий по важности ИМТ(bmi), а в Dim2 он второй - попробуем его сделать дамми в добавок к тому, что делали выше:

insur_v_4 <- insur %>% 
  mutate(
    smoker = if_else(smoker == 'yes', 1, 0),
    sex = if_else(sex == 'female', 1, 0),
    bmi_group = case_when(
      bmi <18.5 ~ "und",
      bmi >=18.5 & bmi <=24.9 ~ "norm",
      bmi > 24.9 & bmi <= 29 ~ "over",
      bmi > 29 ~ "obe"
    ))

#и делаем их дамми
insur_v_4 <- dummy_cols(insur_v_4, select_columns = "bmi_group") 
insur_v_4$bmi <- NULL
insur_v_4$bmi_group <- NULL
insur_v_4$region <- NULL

#PCA
insur.pca_4 <- prcomp(insur_v_4, scale = T)
summary(insur.pca_4)

## Importance of components:
##                           PC1    PC2    PC3    PC4    PC5    PC6    PC7     PC8
## Standard deviation     1.4119 1.2731 1.1244 1.0344 1.0106 0.9979 0.9491 0.36559
## Proportion of Variance 0.2215 0.1801 0.1405 0.1189 0.1135 0.1106 0.1001 0.01485
## Cumulative Proportion  0.2215 0.4016 0.5421 0.6610 0.7744 0.8851 0.9851 1.00000
##                              PC9
## Standard deviation     1.316e-15
## Proportion of Variance 0.000e+00
## Cumulative Proportion  1.000e+00

fviz_eig(insur.pca_4, 
         addlabels = T, 
         ylim = c(0, 40))

fviz_contrib(insur.pca_4, choice = "var", axes = 1) # 1

fviz_contrib(insur.pca_4, choice = "var", axes = 2) # 2

fviz_contrib(insur.pca_4, choice = "var", axes = 3) # 3

ggbiplot(insur.pca_4, 
         scale=0) +
  theme_minimal()

Поменялся порядо параметров в Dim1 (теперь ИМТ соответствующий сильному ожирению важен)

Если просто регионы вырзать

insur_v_5 <- insur_wD %>%
  select(!contains("region"))

#PCA
insur.pca_5 <- prcomp(insur_v_5, scale = T)
summary(insur.pca_5)

## Importance of components:
##                           PC1    PC2    PC3    PC4    PC5     PC6       PC7
## Standard deviation     1.6672 1.4022 1.0984 0.9961 0.9419 0.41050 2.045e-15
## Proportion of Variance 0.3475 0.2458 0.1508 0.1240 0.1109 0.02106 0.000e+00
## Cumulative Proportion  0.3475 0.5932 0.7440 0.8680 0.9789 1.00000 1.000e+00
##                              PC8
## Standard deviation     7.479e-16
## Proportion of Variance 0.000e+00
## Cumulative Proportion  1.000e+00

fviz_eig(insur.pca_5, 
         addlabels = T, 
         ylim = c(0, 40))

fviz_contrib(insur.pca_5, choice = "var", axes = 1) # 1

fviz_contrib(insur.pca_5, choice = "var", axes = 2) # 2

fviz_contrib(insur.pca_5, choice = "var", axes = 3) # 3

ggbiplot(insur.pca_5, 
         scale=0) +
  theme_minimal()

60% достигается на 3, а 90% на 5ой. Так что вроде как стало лучше